MS-DOS File Utilities ( MS-DOS file utilities: DIR ) : .DIR ( addr -- ; print directory entry at addr ) DUP >R .DRIVE R 1+ .FNAME R 29 + .FSIZE R 25 + .DATE R> 23 + .TIME SPACE ; 0 FILE SEARCH-FCB : DIR" ( -- ; print directory listing ) [" ????????.???" SEARCH-FCB @FCB 0 FNAME DROP ( def=*.*) SEARCH-FCB @FCB " DF-NAME DF-EXT + FNAME DROP ( get name ) SEARCH-FCB @FCB PAD ?FIRST IF ." No matching files " ELSE 0 BEGIN CR PAD .DIR 1+ SEARCH-FCB @FCB PAD ?NEXT UNTIL DUP . 1- IF ." files " ELSE ." file " THEN THEN ; ( MS-DOS file utilities: FILES" ) : ?NL OUT @ 70 > IF CR 0 OUT ! ELSE 2 SPACES THEN ; : .FNAMER ( addr -- ;print filename right justified ) DUP 8 -TRAILING 8 OVER - SPACES TYPE 46 EMIT 8 + 3 TYPE SPACE ; : FILES" ( -- ; print filenames in directory ) [" ????????.???" SEARCH-FCB @FCB 0 FNAME DROP ( def=*.*) SEARCH-FCB @FCB " DF-NAME DF-EXT + FNAME DROP ( get name ) SEARCH-FCB @FCB PAD ?FIRST IF ." No matching files " ELSE 80 OUT ! 0 BEGIN ?NL PAD 1+ .FNAMER 1+ SEARCH-FCB @FCB PAD ?NEXT UNTIL ?NL DUP . 1- IF ." files " ELSE ." file " THEN THEN ; ( MS-DOS file utilities: ERASE" ) : ERASE" ( -- ;equivalent to MS-DOS ERASE, lists erased files) SEARCH-FCB @FCB " 0 FNAME DROP ( get name ) SEARCH-FCB @FCB PAD ?FIRST IF ." No matching files " ELSE BEGIN CR PAD 1+ .FNAMER ( print name ) PAD FDEL ( kill it! ) IF ." couldn't erase " THEN SEARCH-FCB @FCB PAD ?NEXT ( get next match ) UNTIL THEN ; ( MS-DOS file utilities: SAVE-MEMORY, SAVE-FORTH ) : /SAVE-MEMORY ( addr n fd -- ;write n bytes to file ) DUP >R /CREATE R /WRITE R /? R> /CLOSE ; : /SAVE-FORTH" ( fd --;save memory image of FORTH ) DUP /IS" ABORT" No */? allowed " 0 +ORIGIN HERE OVER - ROT /SAVE-MEMORY ; ;S ( to save FORTH: execute NEW, define a file, then use ) ( SAVE-FORTH to write FORTH to the file. ) ( e.g. NEW ... >FILE S4 S4 SAVE-FORTH" X4TH.COM" ) ( NOTE: Make sure no open files are in the dictionary: ) ( they will appear to be open when FORTH is re-loaded ! ) ( LOG, END-LOG ) >FILE LOGFILE : XCR 13 EMIT 10 EMIT ; : LOG-EMIT DUP (EMIT) LOGFILE /PUTC IF ( error ! ) ' (EMIT) CFA @EMIT ! LOGFILE /CLOSE CR ." ERROR -- log aborted " CR THEN ; : LOG LOGFILE ?SHUT LOGFILE IS LOGFILE /CREATE ' LOG-EMIT CFA @EMIT ! ' XCR CFA @CR ! ; : END-LOG ' (EMIT) CFA @EMIT ! ' (CR) CFA @CR ! EOF LOGFILE /PUTC DROP LOGFILE DUP /? /CLOSE ; ( fig <---> file copy utility ) : PAUSE ." Hit any key to proceed..." KEY DROP ; : COPY>FILE ( -- ; copy screens to a file ) CR ." Make sure drive A has the fig-FORTH disk. " PAUSE ' BLKRD CFA @BLKRD ! CR CR ." Ready to copy to file. " CR CR ." Use #SCRCOPY ( from to n -- ) to copy. " ." Use EOF to quit. " ; : COPY>SCR ( copy file screens to fig-disk ) CR ." Make sure drive A has the fig-FORTH disk. " PAUSE ' BLKWRT CFA @BLKWRT ! CR CR ." Ready to copy to screens. " CR CR ." Use #SCRCOPY ( from to n -- ) to copy. " ." Use EOF to quit. " ; ( MS-DOS file utilities: PACSCREEN ) >FILE PAC-FILE : /TYPE ( addr n fd -- ;send n chars to fd ) ROT ROT -DUP IF ( n>0 ) OVER + SWAP DO I C@ 32 MAX OVER /PUTC ABORT" error writing PAC-FILE" LOOP ELSE DROP THEN DROP ; : PACSCREEN ( n fd -- ;send block n to fd ) SWAP BLOCK DUP B/BUF + SWAP DO I C/L -TRAILING ROT DUP >R /TYPE 13 R /PUTC 10 R /PUTC DROP DROP R> C/L +LOOP DROP ; --> ( MS-DOS file utilities: PACK" ) : PACK" ( -- ;write the current screen file to a packed file ) SCREENS ?OPEN [" .PAC" PAC-FILE @FCB 0 FNAME DROP PAC-FILE @FCB " DF-EXT FNAME ( get name, ext def's to .PAC) ABORT" no */? allowed" PAC-FILE /CREATE SCREENS /BLKS 0 CR DO ( start at 0, to last block ) I PAC-FILE PACSCREEN I ." Scr " . LOOP 26 PAC-FILE /PUTC ( CTRL-Z EOF ) DROP PAC-FILE DUP /? /CLOSE ; ;S
